      SUBROUTINE SHADES(K,N,DIZ,FTAK,FTBK)
C
C           'SHADES' CALCULATES THERMAL LAG OF ELEMENT THERMAL FORCES
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      COMMON/IPOOL1/ IGRAV,IDAMP,IK,K1,ITIM,IAB,IAPS,IBB,IBPS,NK(10),
     .               LK(10),LLK(10)
C
      COMMON/ISHADE/ IPLANS,ISATSH,IWRTTF
C
      COMMON/ITDLAY/ ITIMIN,ISSWCH,IPDLAY,JENTRY
C
      COMMON/SATLSH/ TAUK(10),OCULTK(10),RADSH
C
      COMMON/RPOOL1/ RHOK(10),T   ,SA(3,3),FM1(3,3),ZLK(10),OMEG(3),
     .               ZLKP(10),ZLKDP(10),CMAT(3,3),GBAR(3,3),YBCM(3),
     .               ZBZK(3,10),FCM(3,3),DTO,PHID,PHI
C
      DIMENSION DIZ(3),DIK(3),FTAKD(10,3),FTBKD(10,3),ISATD(10)
      DIMENSION TREF(10)
C
C
      IF(JENTRY.EQ.2) GO TO 10
C
      DO 5 I=1,10
      DO 4 J=1,3
      FTAKD(I,J) = 0.0D0
      FTBKD(I,J) = 0.0D0
    4 CONTINUE
      TREF(I)=T
      ISATD(I)=0
    5 CONTINUE
      JENTRY=2
C
   10 CONTINUE
C
C
      DO 11 I=1,3
      DIK(I)=DIZ(I)
   11 CONTINUE
C
      MTEST=1
      IF(ISATSH.EQ.0) GO TO 135
      IF(N.EQ.1) CALL SHADEK(DIK,PERSUN,PERSND,INDS,K,ISATD)
      IF(INDS.EQ.0.OR.ITIMIN.EQ.0) GO TO 100
      ITEST=ISATD(K)
       IF (ITEST .EQ. INDS) GO TO 100
      AREF=PERSUN*FTAK
      BREF=PERSUN*FTBK
       IF (ITEST .EQ. 0)GO TO 30
      WS1=-(T-TREF(K))/TAUK(K)
      IF((WS1+10.0D0).GT.0.0D0) GO TO 25
      WS2=0.0D0
      GO TO 26
   25 CONTINUE
      WS2=DEXP(WS1)
   26 CONTINUE
      AREF=FTAKD(K,N)*WS2+(1.0D0-WS2)*AREF
      BREF=FTBKD(K,N)*WS2+(1.0D0-WS2)*BREF
   30 CONTINUE
      FTAKD(K,N)=AREF
      FTBKD(K,N)=BREF
      TREF(K)=T
      IF(N.EQ.NK(K)) ISATD(K)=INDS
  100 CONTINUE
      AREF=PERSUN*FTAK
      BREF=PERSUN*FTBK
  124 CONTINUE
      ITEST=ISATD(K)
      IF(ITEST.EQ.0) GO TO 130
      WS1=-(T-TREF(K))/TAUK(K)
      IF((WS1+10.0D0).GT.0.0D0) GO TO 125
      WS2=0.0D0
      ISATD(K)=0
      GO TO 126
  125 CONTINUE
      WS2=DEXP(WS1)
  126 CONTINUE
      SFTAK=FTAKD(K,N)*WS2+(1.0D0-WS2)*AREF
      SFTBK=FTBKD(K,N)*WS2+(1.0D0-WS2)*BREF
      GO TO (140,200) ,MTEST
  130 CONTINUE
      SFTAK=AREF
      SFTBK=BREF
      GO TO (140,200) ,MTEST
  135 CONTINUE
      SFTAK=FTAK
      SFTBK=FTBK
  140 CONTINUE
      IF(IPLANS.EQ.0) GO TO 200
      IF(ISSWCH.EQ.0.OR.ITIMIN.EQ.0) GO TO 150
      IPDLAY=ISSWCH
      FTAKD(K,N)=SFTAK
      FTBKD(K,N)=SFTBK
      TREF(K)=T
      IF(N.EQ.NK(K)) ISATD(K)=ISSWCH
  150 CONTINUE
      IF(IPDLAY.EQ.0) GO TO 200
      MTEST=2
      AREF=SFTAK
      BREF=SFTBK
      GO TO 124
  200 CONTINUE
      FTAK=SFTAK
      FTBK=SFTBK
      RETURN
      END
